home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
ada
/
gwuada_9.zip
/
3A.C
< prev
next >
Wrap
C/C++ Source or Header
|
1993-07-27
|
58KB
|
1,827 lines
/*
* Copyright (C) 1985-1992 New York University
*
* This file is part of the Ada/Ed-C system. See the Ada/Ed README file for
* warranty (none) and distribution info and also the GNU General Public
* License for more details.
*/
#include "3.h"
#include "attr.h"
#include "arithp.h"
#include "miscp.h"
#include "smiscp.h"
#include "dclmapp.h"
#include "nodesp.h"
#include "errmsgp.h"
#include "evalp.h"
#include "setp.h"
#include "chapp.h"
extern int *ADA_MIN_FIXED_MP, *ADA_MAX_FIXED_MP;
static void const_redecl(Node, Node, Node);
static Symbol set_type_mark(Tuple, Node);
static void build_type(Symbol, Node, Node);
static void derived_type(Symbol, Node);
static void build_derived_type(Symbol, Symbol, Node);
static int in_unconstrained_natures(int);
static int is_derived_type(Symbol);
static void derive_subprograms(Symbol, Symbol);
static void derive1_subprogram(Symbol, Symbol, Symbol, Symbol);
static int hidden_derived(Symbol, Symbol);
static Symbol find_neq(Symbol);
static void new_enum_type(Symbol, Node);
static void new_integer_type(Symbol, Node);
static void new_floating_type(Symbol, Node);
static void new_fixed_type(Symbol, Node);
static Node real_bound(Node, Symbol);
static Symbol constrain_scalar(Symbol, Node);
void obj_decl(Node node) /*;obj_decl*/
{
/* Process variable declaration. Verify that the type is a constrained one,
* or that default values exist for the discriminants of the type.
*/
Node id_list_node, type_indic_node, init_node, id_node, node1;
Symbol type_mark, t_m, n;
int i;
Tuple nam_list, id_nodes;
Fortup ft1;
if (cdebug2 > 3) TO_ERRFILE("AT PROC : obj_decl");
id_list_node = N_AST1(node);
type_indic_node = N_AST2(node);
init_node = N_AST3(node);
id_nodes = N_LIST(id_list_node);
nam_list = tup_new(tup_size(id_nodes));
FORTUPI(id_node =(Node) , id_nodes, i, ft1);
nam_list[i] = (char *) find_new(N_VAL(id_node));
ENDFORTUP(ft1);
type_mark = set_type_mark(nam_list, type_indic_node);
current_node = type_indic_node;
check_fully_declared(type_mark);
adasem(init_node);
/* If an initialization is provided, verify it has the specified type. */
if (init_node != OPT_NODE)
t_m = check_init(type_indic_node, init_node);
if (is_unconstrained(type_mark)) {
errmsg_nat("Unconstrained % in object declaration", type_mark,
"3.6.1, 3.7.2", type_indic_node);
}
/*(forall n in nam_list) nature(n) := na_obj; end forall;*/
FORTUP(n=(Symbol), nam_list, ft1);
NATURE(n) = na_obj;
ENDFORTUP(ft1);
for (i = 1; i <= tup_size(id_nodes); i++) {
node1 = (Node) id_nodes[i];
N_UNQ(node1) = (Symbol) nam_list[i];
}
}
void const_decl(Node node) /*;const_decl*/
{
/* Process constant declarations. This may be a new declaration, or the
* full declaration of a deferred constant in the private part of a
* package. In this later case, recover the names of the constants, and
* update their definitions.
*/
Node id_list_node, type_indic_node, init_node, id_node;
Tuple id_nodes, id_list, nam_list;
Symbol type_mark, t_m, n;
char *id;
int i, exists;
Fortup ft1;
Symbol s;
if (cdebug2 > 3) TO_ERRFILE("AT PROC : const_decl");
id_list_node = N_AST1(node);
type_indic_node = N_AST2(node);
init_node = N_AST3(node);
id_nodes = N_LIST(id_list_node);
id_list = tup_new(tup_size(id_nodes));
FORTUPI(id_node =(Node), id_nodes, i, ft1);
id_list[i] = N_VAL(id_node);
ENDFORTUP(ft1);
adasem(init_node);
if (NATURE(scope_name) == na_private_part) {
exists = FALSE;
FORTUP(id=, id_list, ft1);
if (dcl_get(DECLARED(scope_name), id) != (Symbol)0) {
exists = TRUE;
break;
}
ENDFORTUP(ft1);
if (exists ){
/* It must be a deferred constant. */
const_redecl(id_list_node, type_indic_node, init_node);
return;
/* Otherwise it is a fully private constant. */
}
}
nam_list = tup_new(tup_size(id_list));
FORTUPI(id =, id_list, i, ft1);
nam_list[i] = (char *) find_new(id);
ENDFORTUP(ft1);
type_mark = set_type_mark(nam_list, type_indic_node);
if (init_node == OPT_NODE) {
/* Deferred constant.*/
s = TYPE_OF(base_type(type_mark));
if (s != symbol_private && s != symbol_limited_private) {
errmsg("Missing initialization in constant declaration", "3.2",
node);
}
else if (SCOPE_OF(type_mark) != scope_name) {
errmsg("Wrong scope for type of deferred constant", "7.4",
type_indic_node);
}
else if ( (NATURE(scope_name) != na_package_spec)
&& (NATURE(scope_name) != na_generic_package_spec) ) {
errmsg("Invalid context for deferred constant", "3.2, 7.4", node);
}
else if (is_generic_type(type_mark)
|| is_generic_type(base_type(type_mark))) {
errmsg("constants of a generic type cannot be deferred", "12.1.2",
node);
}
else if (is_anonymous(type_mark)) {
errmsg("a deferred constant must be defined with a type mark",
"7.4.3", node);
}
}
else {
t_m = check_init(type_indic_node, init_node);
if (t_m != type_mark) {
/* t_m is an anonymous type created from the bounds of init value*/
FORTUP(n = (Symbol), nam_list, ft1);
TYPE_OF(n) = t_m;
ENDFORTUP(ft1);
}
}
FORTUP(n =(Symbol), nam_list, ft1);
NATURE(n) = na_constant;
SIGNATURE(n) = (Tuple) init_node;
ENDFORTUP(ft1);
for (i = 1; i <= tup_size(id_nodes); i++) {
Node tmp = (Node) id_nodes[i];
N_UNQ(tmp) = (Symbol) nam_list[i];
}
}
static void const_redecl(Node id_list_node, Node type_indic_node,
Node init_node) /*;const_redecl*/
{
/* Process the full declaration of deferred constants. at least one id
* in id_list is know to have been declared in the visible part of the
* current scope.
*/
Symbol u_n, t_m, type_mark;
Symbol ut;
Node id_node, tmp;
Tuple id_nodes, nam_list, id_list;
char *id;
int i;
Fortup ft1;
if (cdebug2 > 3) TO_ERRFILE("AT PROC : const_redecl");
id_nodes = N_LIST(id_list_node);
id_list = tup_new(tup_size(id_nodes));
FORTUPI(id_node =(Node), id_nodes, i, ft1);
id_list[i] = N_VAL(id_node);
ENDFORTUP(ft1);
nam_list = tup_new(0);
/* The type indication must be a subtype indication .*/
if (N_KIND(type_indic_node) == as_subtype_indic) {
adasem(type_indic_node);
type_mark = promote_subtype(make_subtype(type_indic_node));
}
else
/* An anonymous array is syntactically possible, but incorrect. */
type_mark = anonymous_array(type_indic_node);
N_UNQ(type_indic_node) = type_mark;
FORTUP(id =, id_list, ft1);
u_n = dcl_get(DECLARED(scope_name), id);
if (u_n == (Symbol)0) {
errmsg_str("% is not a deferred constant", id, "3.2, 7.4",
id_list_node);
nam_list = tup_with(nam_list, (char *)symbol_any);
continue;
}
else if((NATURE(u_n) != na_constant)
|| ((Node) SIGNATURE(u_n) != OPT_NODE)) {
errmsg_str("Invalid redeclaration of %", id, "8.3", id_list_node);
nam_list = tup_with(nam_list, (char *)symbol_any);
continue;
}
else if ( ((ut = TYPE_OF(u_n)) != type_mark)
/* They may still be the same subtype of some private type.*/
&& (TYPE_OF(ut) != TYPE_OF(type_mark))
|| (SIGNATURE(ut) != SIGNATURE(type_mark)))
{
errmsg_str("incorrect type in redeclaration of %", id,
"7.4, 7.4.1", id_list_node);
nam_list = tup_with(nam_list, (char *)symbol_any);
}
else if (init_node == OPT_NODE) { /* No initiali(zation ? */
errmsg_str("Missing initialization in redeclaration of %", id,
"7.4", id_list_node);
nam_list = tup_with(nam_list, (char *)symbol_any);
}
else {
TO_XREF(u_n);
nam_list = tup_with(nam_list, (char *) u_n);
}
ENDFORTUP(ft1);
for (i = 1; i <= tup_size(id_nodes); i++) {
tmp = (Node) id_nodes[i];
N_UNQ(tmp ) = (Symbol) nam_list[i];
}
if (init_node != OPT_NODE ) {
t_m = check_init(type_indic_node, init_node);
FORTUP(u_n=(Symbol), nam_list, ft1);
SIGNATURE(u_n) = (Tuple) init_node;
ENDFORTUP(ft1);
}
}
static Symbol set_type_mark(Tuple nam_list, Node type_indic_node)
/*;set_type_mark*/
{
/* Set the symbol table entry for object or constant declarations.
* The type indication is a subtype indication or an array definition. In
* the later case, an anonymous array type must be created for each item
* in the name list. For the interpreter, any